Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/bitmap1g/hitcount.ctl

Text File | 1999-07-15 | 8KB | 251 lines

VERSION 5.00
Object = "{27395F88-0C0C-101B-A3C9-08002B2F49FB}#1.1#0"; "PICCLP32.OCX"
Begin VB.UserControl HitCounter
   Appearance      =   0  'Flat
   ClientHeight    =   465
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4740
   ClipControls    =   0   'False
   ScaleHeight     =   31
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   316
   ToolboxBitmap   =   "HitCounter.ctx":0000
   Begin PicClip.PictureClip PicClip
      Left            =   0
      Top             =   0
      _ExtentX        =   6615
      _ExtentY        =   661
      _Version        =   327681
      Cols            =   10
      Picture         =   "HitCounter.ctx":0312
   End
   Begin VB.Image Numeral
      Enabled         =   0   'False
      Height          =   990
      Index           =   0
      Left            =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   540
   End
End
Attribute VB_Name = "HitCounter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Const CHAR_CNT As Integer = 10
Const TITLE As String = "HitCounter"
Const KEY As String = "Value"
Const D_GRAY As Long = &HC0C0C0

Enum BorderStyles
    None
    Fixed
End Enum

Dim Numerals() As IPictureDisp
Dim HitCnt As Long

Dim Nums As Integer
Dim NumCnt As Integer
Dim NumSpc As Integer
Dim InRunMode As Boolean
Dim Initialized As Boolean

Event Click()
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Event DblClick()
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object."
Event KeyDown(KeyCode As Integer, Shift As Integer)
Attribute KeyDown.VB_Description = "Occurs when the user presses a key while an object has the focus."
Event KeyPress(KeyAscii As Integer)
Attribute KeyPress.VB_Description = "Occurs when the user presses and releases an ANSI key."
Event KeyUp(KeyCode As Integer, Shift As Integer)
Attribute KeyUp.VB_Description = "Occurs when the user releases a key while an object has the focus."
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."

Public Property Get BorderStyle() As BorderStyles
    BorderStyle = UserControl.BorderStyle
End Property

Property Let BorderStyle(NewStyle As BorderStyles)
    UserControl.BorderStyle = NewStyle
    PropertyChanged "BorderStyle"
End Property

Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor = New_BackColor
    PropertyChanged "BackColor"
End Property

Public Property Get Space() As Integer
    Space = NumSpc
End Property

Public Property Let Space(ByVal New_Space As Integer)
    NumSpc = New_Space
    PropertyChanged "Space"
    Display
End Property

Property Get NumeralCount() As Integer
    NumeralCount = Nums
End Property

Property Let NumeralCount(New_NumeralCount As Integer)
    Nums = New_NumeralCount
    PropertyChanged "NumeralCount"
    UserControl_Resize
    Display
End Property

Public Property Get NumeralPicture() As Picture
Attribute NumeralPicture.VB_Description = "Same as the standard Picture property except that it only supports bitmap (.BMP) files."
    Set NumeralPicture = PicClip.Picture
End Property

Public Property Set NumeralPicture(ByVal New_NumeralPicture As Picture)
    Set PicClip.Picture = New_NumeralPicture
    PropertyChanged "NumeralPicture"
    LoadNumerals
    Display
End Property

Private Sub Numeral_Click(Index As Integer)
    RaiseEvent Click
End Sub

Private Sub UserControl_Click()
    RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub UserControl_InitProperties()
    UserControl.BackColor = D_GRAY
    Debug.Print "BorderChanged"
    NumSpc = 2
    Initialized = True
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, ScaleX(X, ScaleMode, vbContainerPosition), ScaleX(Y, ScaleMode, vbContainerPosition))
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, ScaleX(X, ScaleMode, vbContainerPosition), ScaleX(Y, ScaleMode, vbContainerPosition))
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", D_GRAY)
    UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", None)
    NumSpc = PropBag.ReadProperty("Space", 2)
    Nums = PropBag.ReadProperty("NumeralCount", 0)
    Set Picture = PropBag.ReadProperty("NumeralPicture", Nothing)
    InRunMode = Ambient.UserMode
    LoadNumerals
    Display
End Sub

Private Sub UserControl_Resize()
Dim X As Double, Y As Double
    If Initialized Then
        Initialized = False
        X = PicClip.CellWidth * Len(HitCount) - Len(HitCount) + NumSpc * 2 + 1
        Y = PicClip.CellHeight + NumSpc * 2
        If BorderStyle = Fixed Then X = X + 2: Y = Y + 2
        UserControl.Width = ScaleX(X, ScaleMode, 1)
        UserControl.Height = ScaleX(Y, ScaleMode, 1)
    End If
    Initialized = True
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "BackColor", UserControl.BackColor, D_GRAY
    PropBag.WriteProperty "BorderStyle", UserControl.BorderStyle, None
    PropBag.WriteProperty "Space", NumSpc, 2
    PropBag.WriteProperty "NumeralCount", Nums, 0
    PropBag.WriteProperty "NumeralPicture", Picture, Nothing
End Sub

Private Sub LoadNumerals()
    For NumCnt = 0 To CHAR_CNT - 1
        ReDim Preserve Numerals(0 To NumCnt)
        Set Numerals(NumCnt) = PicClip.GraphicCell(NumCnt)
    Next NumCnt
End Sub

Public Sub ResetHits(Optional ResetValue As Long)
    If Not Initialized Then Exit Sub
    HitCnt = ResetValue - 1
    PerformHit
    Display
End Sub

Public Function HitCount() As String
Dim RegHits As Long
    RegHits = Abs(Val(GetSetting(TITLE, Parent.Name & "." & Ambient.DisplayName, KEY, 0)))
    HitCount = Format(RegHits, String(Nums, "0"))
End Function

Public Sub PerformHit()
Dim i As Integer
    If InRunMode Then i = 1
    HitCnt = Val(HitCnt) + i
    SaveSetting TITLE, Parent.Name & "." & Ambient.DisplayName, KEY, HitCnt
    Display
End Sub

Private Sub Display()
Dim CharCnt As Integer
Dim i As Integer, CurNum As Integer
Dim X As Integer
    KillBoxes
    UserControl_Resize
    CharCnt = Len(HitCount)
    X = NumSpc
    For i = 1 To CharCnt
        Load Numeral(i)
        CurNum = Val(Right(Left(HitCount, i), 1))
        Numeral(i).Left = X
        Numeral(i).Top = NumSpc
        Numeral(i).Visible = True
        Numeral(i).Picture = Numerals(CurNum)
        X = X + Numeral(i).Width - 1
    Next i
End Sub

Private Sub KillBoxes()
Dim BoxCount As Integer
    On Error Resume Next
    For BoxCount = CHAR_CNT To 1 Step -1
        Unload Numeral(BoxCount)
    Next BoxCount
End Sub